perm filename FIE[1,LMM] blob
sn#128794 filedate 1974-11-04 generic text, type T, neo UTF8
(FILECREATED " 3-NOV-74 00:37:15" WARREN.;16 15182
changes to: WARRENCOMS
previous date: " 2-NOV-74 23:43:12" WARREN.;15)
(LISPXPRINT (QUOTE WARRENCOMS)
T T)
[RPAQQ WARRENCOMS
((FNS PPF PPF1 PPF2)
(USERMACROS - EF EV EP ?= EVAL)
(FNS FIRSTATOM DO?=)
(FNS MAPFILES)
[ADDVARS (LISPXMACROS [DEL (DIR (CAR LISPXLINE)
(CONS (QUOTE P)
(APPEND (CDR LISPXLINE)
(QUOTE (!DELETE]
(DIR (DIR (CAR LISPXLINE)
(CONS (QUOTE P)
(CDR LISPXLINE]
(FNS DIR DIR1 DELJ DREAD DTAB)
(BLOCKS (DIR DIR DIR1 DREAD DELJ DTAB (LOCALFREEVARS TOTALSIZE
COMMANDS I JFN)
(GLOBALVARS DIRTTBL)))
(ADDVARS (HISTORYCOMS ; ...)
(LISPXCOMS ;)
(LISPXHISTORYMACROS (; NIL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA PPF)
(NLAML]
(DEFINEQ
(PPF
[NLAMBDA FNL
(RESETFORM (SETTERMTABLE (OR (TERMTABLEP PPFTERMTABLE)
(PROGN (/RPLACA (QUOTE PPFTERMTABLE)
(COPYTERMTABLE (QUOTE ORIG)))
(FOR I
IN (QUOTE (1 2 3 4 5 6 10Q 30Q))
DO (ECHOCONTROL I (QUOTE IGNORE)
PPFTERMTABLE))
PPFTERMTABLE)))
(COND
((NLISTP FNL)
(PPF1 FNL T))
(T (MAPC FNL (FUNCTION (LAMBDA (X)
(PPF1 X T])
(PPF1
[LAMBDA (FN ALLFILESFLG)
(PROG (FOUND)
(for FL in FILELST
do (SETQ FOUND (OR (PPF2 FN FL (AND (NOT FOUND)
ALLFILESFLG)
NIL)
FOUND)))
(AND
(NOT FOUND)
(COND
[(GETP FN (QUOTE FILEDEF))
(PPF2 FN (NAMEFIELD (GETP FN (QUOTE FILEDEF)))
(NOT FOUND)
(QUOTE (NEWLISP LISP]
(T (SETQ ALLFILESFLG (OR (FGETD FN)
ALLFILESFLG))
(for FL in SYSFILES when (NOT (FMEMB FL FILELST))
do (SETQ FOUND (OR (PPF2 FN FL NIL
(QUOTE (NEWLISP LISP)))
FOUND)))
(AND (NOT FOUND)
(for FL in SYSFILES
when (NOT (FMEMB FL FILELST))
do (SETQ FOUND
(OR (PPF2 FN FL (NOT FOUND)
(QUOTE (NEWLISP LISP)))
FOUND])
(PPF2
[LAMBDA (FN FILE GETMAP DEFAULTDIRS)
(RESETLST
(PROG (TEM TEM2)
(COND
([COND
([SETQ TEM2
(COND
((GETP FILE (QUOTE FILEMAP)))
(GETMAP
[COND
((LISTP (SETQ TEM2 (FILECOMS FILE)))
(OR (NEWFILE2 FN TEM2)
(RETURN]
[COND
((SETQ TEM2 (OPENP FILE (QUOTE INPUT)))
(SETQ TEM (SFPTR TEM2 0))
(RESETSAVE NIL (LIST (QUOTE SFPTR)
TEM2 TEM)))
(T
[SETQ TEM
(COND
[DEFAULTDIRS
(INFILE
(OR (INFILEP FILE)
[for X in DEFAULTDIRS
any (INFILEP (PACK (LIST "<" X ">"
FILE]
(RETURN]
(T (CAR (OR (NLSETQ (INFILE FILE))
(RETURN]
[RESETSAVE NIL (LIST (QUOTE CLOSEF)
(SETQ TEM2 (INPUT]
(RESETSAVE NIL (LIST (QUOTE INPUT)
TEM]
(/PUT FILE (QUOTE FILEMAP)
(AND (SETQ TEM (GETFILEMAP TEM2 FILE))
(CONS TEM2 TEM]
(OR (NULL (CADR TEM2))
(NEQ GETMAP (QUOTE ALL)))
(SETQ TEM (for X in (CDDR TEM2) any (ASSOC FN (CDDR X]
[COND
((NOT (OPENP (CAR TEM2)))
(INPUT (INFILE (CAR TEM2)))
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
(CAR TEM2]
(PRINT (LIST (QUOTE from)
(CAR TEM2))
T T)
(COPYBYTES (CAR TEM2)
T
(CADR TEM)
(CDDR TEM))
(TERPRI T)
T])
)
[ADDTOVAR USERMACROS [?= NIL (ORR ((E (DO?= (##))
T))
((E (QUOTE ?=?]
[EV NIL (ORR [(E (LISPXEVAL (LIST (QUOTE EDITV)
(FIRSTATOM (##)))
(QUOTE EV->]
((E (QUOTE EV?]
[EP NIL (ORR [(E (LISPXEVAL (LIST (QUOTE EDITP)
(FIRSTATOM (##)))
(QUOTE EP->]
((E (QUOTE EP?]
[?= NIL (ORR ((E (?= (##))
T))
((E (QUOTE ?=?]
(- NIL (ORR NX !NX)
(IF (LISPXREADP T)
NIL P))
[EVAL NIL (E (LISPXEVAL (## (ORR (UP 1)
NIL))
(QUOTE *]
[?= NIL (ORR [(E (MAP2C (ARGLIST (## 1))
(## 2 UP)
(FUNCTION (LAMBDA (X Y)
(PRIN1 X T)
(PRIN1 " = " T)
(PRINT Y T]
((E (QUOTE ?=?]
(EF NIL (ORR [(E (LISPXEVAL (LIST (QUOTE EDITF)
(FIRSTATOM (##)))
(QUOTE EF->]
((E (QUOTE EF?]
(ADDTOVAR EDITCOMSA EF ?= EVAL - ?= EP EV ?=)
(DEFINEQ
(FIRSTATOM
[LAMBDA (X) (* Used by EF macro)
(COND
((NLISTP X)
X)
(T (OR (FIRSTATOM (CAR X))
(FIRSTATOM (CDR X])
(DO?=
[LAMBDA (FORM)
(PROG (ARGS)
(COND
[(OR (GETD (CAR FORM))
(EQ (CAR (LISTP (CAR FORM)))
(QUOTE LAMBDA)))
(SETQ ARGS (ARGLIST (CAR FORM]
((SETQ ARGS (GETP (CAR FORM)
(QUOTE EXPR)))
(SETQ ARGS (CADR ARGS)))
(T (ERROR (FIRSTATOM FORM)
"not a function" T)))
(RESETFORM (PRINTLEVEL 3)
(COND
[(OR (NULL ARGS)
(LISTP ARGS))
[MAPC ARGS (FUNCTION (LAMBDA (X)
(PRIN1 X T)
(PRIN1 " = " T)
(SETQ FORM (CDR FORM))
(COND
(FORM (PRINT (CAR FORM)
T))
(T (TERPRI T]
(AND (SETQ FORM (CDR FORM))
(MAPRINT FORM T "plus ... " ")
" NIL (QUOTE PRIN2]
(T (PRIN1 ARGS T)
(MAPRINT (CDR FORM)
T " = ... " ")
" NIL (QUOTE PRIN2])
)
(DEFINEQ
(MAPFILES
[LAMBDA (FILE.* FN FLAGS)
(RESETLST (PROG (JFN JFN1 VAL)
[COND
((FIXP FILE.*)
(SETQ JFN FILE.*))
(T (SETQ JFN (GTJFN FILE.*(QUOTE *)
-3 100101Q))
[COND
((NULL JFN)
(RETURN (ERSTR]
(RESETSAVE NIL (LIST (QUOTE RLJFN)
JFN]
(SETQ JFN1 (LOGAND JFN 777777Q))
LP (SETQ VAL (APPLY* FN (SELECTQ FLAGS
(T NIL)
(JFNS JFN1 FLAGS))
JFN1 VAL))
(AND (ASSEMBLE NIL
(CQ (VAG JFN))
(JSYS 17Q) (* GNJFN)
(SKIPA 1 , KNIL)
(CQ T))
(GO LP))
(RETURN VAL])
)
[ADDTOVAR LISPXMACROS [DEL (DIR (CAR LISPXLINE)
(CONS (QUOTE P)
(APPEND (CDR LISPXLINE)
(QUOTE (!DELETE]
(DIR (DIR (CAR LISPXLINE)
(CONS (QUOTE P)
(CDR LISPXLINE]
(DEFINEQ
(DIR
[LAMBDA (FILEGROUP COMMANDS)
(RESETLST
[RESETSAVE (SETTERMTABLE
(OR (TERMTABLEP (CAR (QUOTE DIRTTBL)))
(PROGN (/RPLACA (QUOTE DIRTTBL)
(COPYTERMTABLE (QUOTE ORIG)))
(CONTROL T DIRTTBL)
(ECHOMODE NIL DIRTTBL)
DIRTTBL]
(PROG (FILE.* TEM TEM2 VAL DEFAULTEXT DEFAULTVERS (FIRSTCHAR
1747Q)
(TOTALSIZE 0)
(PAT T))
(COND
((MEMB (QUOTE !DELETE)
COMMANDS)
(SETQ DEFAULTEXT "")
(SETQ DEFAULTVERS -2) (* DEFAULT TO -2
(OLDEST VERSION))
)
(T (* -3 IS TEM2 VERSIONS)
(SETQ DEFAULTEXT "*")
(SETQ DEFAULTVERS -3)))
[COND
((EQ (NTHCHAR FILEGROUP -1)
(QUOTE >)) (* JUST A DIRECTORY
NAME)
(SETQ FILEGROUP (CONCAT FILEGROUP "*." DEFAULTEXT ";"
DEFAULTVERS]
[COND
[(OR (NULL FILEGROUP)
(EQ FILEGROUP (QUOTE -))) (* Normal default, file
not specified)
(SETQ FILE.*(PACK (LIST (QUOTE *.)
DEFAULTEXT ";" DEFAULTVERS]
([COND
((NOT (SETQ PAT (STRPOS "≠" FILEGROUP)))
(SETQ TEM (GTJFN FILEGROUP DEFAULTEXT DEFAULTVERS
100101Q)))
((NEQ PAT 1)
(AND (SETQ TEM (GTJFN (SUBSTRING FILEGROUP 1 PAT)
"*" DEFAULTVERS 100101Q))
(SELECTQ (NTHCHAR (SETQ TEM2
(JFNS (LOGAND TEM 777777Q))
)
PAT)
((; %.)
(* If the altmode occured at the end of the name,
then there might be other files beginning with same
chars that wouldn't be caught)
(RLJFN TEM)
NIL)
(OR (EQ PAT (NCHARS FILEGROUP))
(PROGN (RLJFN TEM)
(SETQ TEM
(GTJFN FILEGROUP
DEFAULTEXT
DEFAULTVERS
100101Q]
(SETQ FILE.* TEM))
(T (* Try a pattern match)
(PROG (DIR (NAM T)
(EXT T)
VERS START TEM2 TEM)
(SETQ TEM2 (DUNPACK FILEGROUP SKORLST3))
(COND
[(EQ (CAR TEM2)
(QUOTE <)) (* DIR SPECIFIED)
[SETQ DIR
(LDIFF
(CDR TEM2)
(COND
((SETQ START (MEMB (QUOTE >)
TEM2))
(SETQ START (CDR START)))
(T (CDR (SETQ START
(OR (MEMB (QUOTE ≠)
TEM2)
(ERROR
"Directory incomplete"]
(SETQ DIR
(USERNAME (OR (USERNUMBER (SETQ DIR
(PACK DIR)))
(ERROR "no such directory"
DIR T]
(T (SETQ START TEM2)))
(* START is now the char string starting the file
name -
DIR is the directory name; must actually complete,
or else it errors (the DIR command will NOT map thru
several directories doing pattern matching))
(COND
[(SETQ TEM (MEMB (QUOTE %.)
START))
(* An extention has been
specified; we can
separate name fields
from extension)
(SETQ NAM (LDIFF START TEM))
(COND
((SETQ TEM2 (MEMB (QUOTE ;)
TEM))
(SETQ EXT (LDIFF (CDR TEM)
TEM2))
(SETQ VERS (CDR TEM2))
(* Both extension and
version)
)
(T (SETQ EXT (CDR TEM))
(* extension, no
version)
]
((SETQ TEM (MEMB (QUOTE ;)
START))
(* version, no
extension)
(SETQ NAM (LDIFF START TEM))
(SETQ VERS (CDR TEM)))
(T (SETQ NAM START) (* Neither extension nor
version)
))
(RESETSAVE EDITQUIETFLG T)
(* NAM and VERS are either NIL
(empty field specified), T
(no field specified) or a character list)
[SETQ FILE.*(PACK
(APPEND
[COND
(DIR (LIST (QUOTE <)
DIR
(QUOTE >]
[COND
((OR (EQ NAM T)
(MEMB (QUOTE ≠)
NAM))
(LIST (QUOTE *)))
(T (PROG1 NAM (SETQ NAM T]
(CONS
(QUOTE %.)
(APPEND
[COND
((OR (AND (MEMB (QUOTE ≠)
NAM)
(EQ EXT T))
(MEMB (QUOTE ≠)
EXT))
(QUOTE (*)))
((OR (EQ EXT T)
(MEMB (QUOTE ≠)
EXT))
(LIST DEFAULTEXT))
(T (PROG1 EXT (SETQ EXT T]
(CONS (QUOTE ;)
(OR VERS (LIST DEFAULTVERS]
[SETQ PAT
(CONS (QUOTE ≠)
(APPEND (COND
((OR (EQ NAM T)
(NULL NAM))
(* Name field arbitrary; either it was given in
FILE.* or user had an altmode)
(QUOTE (≠)))
(T NAM))
[COND
((NEQ EXT T)
(* If a period was supplied in original, then can
distinguish between name pattern and extension part)
(QUOTE (%.)))
(T (QUOTE (≠]
(COND
((OR (EQ EXT T)
(NULL EXT))
(QUOTE (≠)))
(T EXT))
(COND
(VERS (CONS (QUOTE ;)
VERS))
(T (QUOTE (≠]
(FOR X ON (CDR PAT)
WHEN (AND (EQ (CAR X)
(QUOTE ≠))
(EQ (CADR X)
(QUOTE ≠)))
DO (RPLNODE2 X (CDR X))
(GO $$LP))
(COND
((EQ (CADR PAT)
(QUOTE ≠))
(OR (CDDR PAT)
(SETQ PAT T)))
(T (SETQ FIRSTCHAR (CHCON1 (CADR PAT]
(PROG (JFN JFN1 (STR (QUOTE "⊗␈]ARCHIVE-DIRECTORY[.;1")))
[COND
((FIXP FILE.*)
(SETQ JFN FILE.*))
(T (SETQ JFN (GTJFN FILE.*(QUOTE *)
-3 100101Q))
(COND
((NULL JFN)
(RETURN (ERSTR]
(RESETSAVE NIL (LIST (QUOTE RLJFN)
JFN))
(SETQ JFN1 (LOGAND JFN 777777Q))
DIRLOOP
(SETQ STR (JFNS JFN1 1210040001Q STR))
[COND
((OR (NLISTP PAT)
(EDIT4E PAT STR)
(COND
((ILESSP FIRSTCHAR (CHCON1 STR))
(RLJFN JFN)
NIL)))
(SETQ VAL (DIR1 STR JFN1 VAL]
(AND (ASSEMBLE NIL
(CQ (VAG JFN))
(JSYS 17Q) (* GNJFN)
(SKIPA 1 , KNIL)
(CQ T))
(GO DIRLOOP)))
(TAB 0 0)
(COND
((NOT (ZEROP TOTALSIZE))
(PRIN2 TOTALSIZE)
(PRIN1 " pages total
")
NIL))
(RETURN VAL])
(DIR1
[LAMBDA (FL JFN VAL)
(PROG (X (I -17Q)
(Y COMMANDS))
(ON OLD Y
DO (SELECTQ (CAR Y)
(P (DTAB)
(PRIN1 FL))
((SI)
(DTAB)
(PRIN2 (SETQ X
(JSYS 36Q JFN NIL NIL 3)))
(SETQ TOTALSIZE (IPLUS X TOTALSIZE)))
((PAUSE WAIT -)
(READC T))
(@ (* Arbitrary function -
next thing is function)
(APPLY* (CAR (SETQ Y (CDR Y)))
FL JFN))
((DELETE DEL)
(AND (DREAD (QUOTE "delete? "))
(DELJ)))
[COLLECT? (AND (DREAD (QUOTE "? "))
(SETQ VAL (CONS (MKATOM FL)
VAL]
(!DELETE (DELJ))
(COLLECT (SETQ VAL (CONS (MKATOM FL)
VAL)))
((DA TI)
(DTAB)
(JSYS 220Q (OPNJFN (OUTPUT))
(JSYS 63Q JFN 1000014Q 2 2))
(* Do an ODTIM, with the 14'th word of the FDB
(date of write of file))
)
NIL))
(RETURN VAL])
(DELJ
[LAMBDA NIL
(OR (ASSEMBLE NIL
(CQ (VAG JFN))
(HRLI 1 , 400000Q)
(JSYS 26Q)
(SKIPA 1 , KNIL)
(CQ T))
(PRIN1 "- can't delete" T])
(DREAD
[LAMBDA (PROMPT)
(PROG NIL
(DTAB)
(PRIN1 PROMPT T)
LP (SELECTQ (READC T)
(Y (PRIN1 (QUOTE "Yes")
T)
(RETURN T))
(N (PRIN1 (QUOTE "No")
T)
(RETURN))
(PROGN (PRIN1 "π" T)
(GO LP])
(DTAB
[LAMBDA NIL
(TAB (SETQ I (IPLUS 17Q I])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: DIR DIR DIR1 DREAD DELJ DTAB (LOCALFREEVARS TOTALSIZE COMMANDS I JFN)
(GLOBALVARS DIRTTBL))
]
(ADDTOVAR HISTORYCOMS ; ...)
(ADDTOVAR LISPXCOMS ;)
(ADDTOVAR LISPXHISTORYMACROS (; NIL))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA PPF)
(ADDTOVAR NLAML)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (894 3516 (PPF 906 . 1326) (PPF1 1330 . 2111) (PPF2 2115 . 3513))
(4443 5472 (FIRSTATOM 4455 . 4631) (DO?= 4635 . 5469)) (5474 6135 (MAPFILES
5486 . 6132)) (6346 14790 (DIR 6358 . 13245) (DIR1 13249 . 14237) (DELJ 14241
. 14444) (DREAD 14448 . 14730) (DTAB 14734 . 14787)))))
STOP